BMUG PD-ROM 1995 Fall

home *** CD-ROM | disk | FTP | other *** search

/ BMUG PD-ROM 1995 Fall / PD-ROM F95.toast / Programming / Programming Languages / Pocket 6.3 ƒ / Pocket DA / DA Source / dDict.txt next >

Wrap

Text File | 1993-06-25 | 43.1 KB | 1,833 lines | [TEXT/ttxt]

; this file is: Common.txt -- forth words ; Tue Apr 05, 1988 21:59:10 load files >32K ; Thu Apr 07, 1988 15:59:46 nested loads ; Tue Apr 19, 1988 05:05:37 change "?button" ; Mon Apr 25, 1988 15:10:19 implement macros ; Tue Apr 26, 1988 19:49:49 optomizing "back" ; Thu Apr 28, 1988 23:09:23 fix id. better constant,2constant add zero ; Fri Apr 29, 1988 09:43:49 add dliteral ; Sun May 01, 1988 04:24:52 make variable a macro ; Thu May 12, 1988 11:41:08 remove (pdo) add 1- 2- & sp@ use slashFail ; Sun May 29, 1988 20:16:39 make create shorter ; Tue May 31, 1988 14:27:25 make +md a 4 byte macro remove 2- ; Tue Jun 07, 1988 11:39:00 add r0@, s0@, rp@ redo stod ; Sun Jun 23, 1991 09:33:00 add open ; Thu Jan 13, 1992 19:05:00 Floating point math (rewrite 13Apr) ; Sun Feb 02, 1992 00:02:00 fix back ; Wed Apr 01, 1992 00:12:00 change stkchk ; Tue Apr 14, 1992 22:48:00 rearrange to bring essentials toward front ; Sun Apr 19, 1992 23:24:00 split open into 2 parts, add: ae: ;ae> ?gestalt ; Sat Aug 08, 1992 18:53:00 remove ae: ;ae> bye revert stkchk open --> grow ; Sat Jan 23, 1993 21:43:00 fix type and froll ; Fri May 28, 1993 22:50:00 move ?BUTTON and FLITERAL, fix +LOOP and QUIT ; ----- the dictionary ------ DictStart: DC.L 0 ; End of dictionary search DC.B 128+1,13,0,0 ; "{cr}" ( -- ) DC.W DictStart-base CRet: JSR pasting-base(BP) ; interpret from the scrap TST.B fint-base(BP) BEQ.S @0 MOVE.B #0,0(IS,D5) ; replace CR with null @0: JMP Main DC.B 129,0,0,0 ; "{null}" ( -- ) DC.W cret-theLink ; interpret from the keyboard NRet: JSR clearTermBuf-base(BP) CLR.L Counter ; clear input buffer offset TST.B fcolon-base(BP) BNE.S @0 ; don't issue prompt if compiling JSR prompt-base(BP) @0: JMP kdone-base(BP) ; jump back to the application DC.B 128+1,'\',0,0 ; "\" ( -- ) backslash DC.W nret-theLink ; line ending comment Backsl: bra.s cret DC.B 9,'?TE' ; "?terminal" ( -- flag ) DC.W backsl -theLink ; was a key pressed? qTerm: JMP qtcode-base(BP) DC.B 3,'KEY' ; "key" ( -- ascii ) DC.W qterm-theLink ; wait for a key press Key: JMP keycode-base(BP) DC.B 6,'?ST' ; "?stack" ( ? -- ) DC.W key-theLink StkChk: CMPA.L UFlow-base(BP),PS BPL.S @0 RTS @0: JSR space-base(BP) MOVEQ #42,D0 ; print * if stack underflow JSR EmitCode-base(BP) BRA.S huh DC.B 7,'?BU' ; "?button" ( -- flag ) DC.W StkChk-theLink QButton: CLR -(SP) _Button MOVE (SP)+,-(PS) BEQ.S @0 SUBI #257,(PS) @0: RTS DC.B 6,'WHA' ; "whazat" ( -- ) DC.W QButton-theLink WhaZat: JSR dwrd-base(bp) BRA.S huh DC.B 5,'ABO' ; "abort" ( -- ) DC.W whazat-theLink huh: MOVE.L Szero-base(BP),PS MOVEQ #63,D0 ; send ? means not found in dict JSR EmitCode-base(BP) bsr.s crlf BRA.S fin DC.B 4,'QUI' ; "quit" ( -- ) DC.W huh-theLink ; clear stacks and restart fin: JSR emptyfs-base(BP) ; clear pending loads CLR.L fcolon-base(BP) ; initialize flags BSET.B #7,fint-base(BP) JMP nret-base(BP) DC.B 2,'CR',0 ; "cr" ( -- ) output CR to screen DC.W fin-theLink CRLF: JMP doCR-Base(BP) DC.B 3,'.OK' ; ".ok" ( -- ) DC.W crlf-theLink Prompt: JSR space-base(BP) ; send space MOVEQ #111,D0 JSR EmitCode-base(BP) ; send "o" MOVEQ #107,D0 JSR EmitCode-base(BP) ; send "k" JMP space-base(BP) ; send another space & return DC.B 5,'UPP' ; "upper" ( addr -- ) DC.W prompt-theLink ; change a string to upper case Upper: MOVE (PS)+,D0 LEA 0(BP,D0.W),A0 ; get the address CLR D0 MOVE.B (A0),D0 ; get count @0: CMPI.B #$60,0(A0,D0.W) ; BEGIN get char at addr + count BLE.S @1 ; char > 'a' CMPI.B #$7B,0(A0,D0.W) ; char < 'z' BGE.S @1 ; AND IF SUBI.B #32,0(A0,D0.W) ; char 32 - -> char THEN @1: DBRA D0,@0 ; count 1- -> count count NOT UNTIL RTS DC.B 5,'TOK' ; "token" ( -- ) put a token DC.W upper-theLink ; from (IS) into (DP), Token: MOVE #32,-(PS) ; which is at end of dict. BSR.S word JSR here-base(BP) ; Fri Apr 29, 1988 00:27:23 simpl BRA.S Upper DC.B 6,'HEA' ; "header" ( -- ) create a header DC.W token-theLink ; for the current word at DP Header: MOVE Dict,4(DP) ; link header to dictionary MOVE.L DP,Dict ; update DICT SUB.L BP,Dict ; make it a rel.addr addq.l #6,dp ; update DP ; (was) LEA 6(DP),DP RTS DC.B 4,'WOR' ; "word" ( c -- ) c is delimiter DC.W header-theLink ; get chars from (IS) into HERE Word: MOVE.L D4,-(SP) ; preserve the register MOVE (PS)+,D4 ; get delimiter character CLR.L (DP) ; clear token buffer CLR.L D1 ; clear count @0: MOVE.B (IS)+,D0 ; get characters until delimiter CMP.B D4,D0 BEQ.S @1 MOVE.B D0,1(DP,D1) ; place in token buffer ADDQ.B #1,D1 ; increment count BRA.S @0 @1: MOVE.B D1,(DP) ; put count in 1st byte of buffer BEQ.S @0 ; if count is 0 repeat MOVE.L (SP)+,D4 ; restore the register RTS DC.B 1,'''',0,0 ; "'" ( -- rel.addr ) return the DC.W word-theLink ; cfa of the following word Tick: bsr.s token ; get the next word MOVE Dict,-(PS) ; push dict ptr to parmstk bsr.s search ; lookup the current token TST (PS)+ BEQ Whazat RTS DC.B 6,'SEA' ; "search" ( addr -- cfa t OR f ) DC.W tick-theLink Search: MOVE.L (DP),D1 ; put token "stem" in D1 MOVE (PS),D0 ; use A0 as search pointer CLR fmacro-base(BP) ; clear the macro flag @0: LEA 0(BP,D0.W),A0 ; DO TST (A0) ; IF DictStart exit NOFIND BEQ.S nofind CMP.L (A0),D1 ; compare word to candidate BEQ.S find ; IF found, exit FIND BCHG #31,D1 ; set immediate bit CMP.L (A0),D1 ; compare to "immediate" version BEQ.S ifind ; IF found, exit FINDIMM BCHG #31,D1 ; reset immediate bit BCHG #30,D1 ; set macro bit CMP.L (A0),D1 ; compare to "immediate" version BEQ.S mfind ; IF found, exit FINDIMM BCHG #30,D1 ; reset macro bit MOVE 4(A0),D0 ; get link rel.address BRA.S @0 ; LOOP nofind: CLR (PS) ; push fail flag RTS mfind: BSET.B #7,fmacro-base(BP) ; set macro flag BRA.S find ifind: BSET.B #7,fimmed-base(BP) ; set immediate flag find: LEA 6(A0),A0 ; cfa is at 6+nfa SUBA.L BP,A0 ; convert code address to relative MOVE A0,(PS) ; push code rel address MOVE #-1,-(PS) ; push success flag RTS DC.B 6,'NUM' ; "number" ( addr -- n t OR f ) DC.W search-theLink Number: MOVE.L D4,-(SP) ; save the register CLR.L D1 CLR.L D4 ; clear conversion register MOVE (PS)+,D0 ; get token addr in D0 LEA 0(BP,D0.W),A0 ; put abs.addr in A0 CMPI.B #'-',1(A0) ; is it negative? BNE.S @0 ; IF yes BSET.B #7,fneg-base(BP) ; set negative flag MOVE.B #'0',1(A0) ; change dash to zero @0: CLR.L D0 ; THEN MOVE.B (A0)+,D1 ; get digit count digit: MOVE.B (A0)+,D0 ; BEGIN get next digit SUBI.B #48,D0 ; strip ASCII prefix BLT.S @2 ; if digit too small, FAIL CMP #10,D0 ; if digit > 9 BLT.S @1 ; adjust for radix>10 values SUBI.B #7,D0 ; and test again CMP #10,D0 BLT.S @2 @1: CMP NBase-base(BP),D0 ; if base < digit BGE.S @2 ; FAIL MULU NBase-base(BP),D4 ; multiply value by base ADD D0,D4 ; add current digit SUBQ.B #1,D1 ; decrement count BNE.S digit ; UNTIL no digits remain BCLR #7,fneg-base(BP) ; test and clear negative flag BEQ.S @0 ; if set NEG D4 ; Negate it @0: MOVE D4,-(PS) ; push number MOVE #-1,-(PS) ; push success flag BRA.S @3 @2: CLR -(PS) ; push fail flag @3: MOVE.L (SP)+,D4 ; restore the register RTS DC.B 7,'FNU' ; FNUMBER ( dabs.addr -- f ) DC.W number-theLink ; convert string at dabs.addr to fp fnum: MOVE.L (PS)+,-(RS) MOVE #1,-(PS) PEA (PS) PEA $14(DP) CLR -(PS) PEA (PS) FPSTR2DEC ADDQ.L #4,PS CMPI #$054E,24(DP) ; check for NAN## BNE.S @0 JMP whazat-base(BP) @0: PEA $14(DP) SUBQ.L #6,PS SUBQ.L #4,PS PEA (PS) FDEC2X RTS DC.B 7,'EXE' ; "execute" ( cfa -- ) do a routine DC.W fnum-theLink ; whose cfa is on the stack EXECUTE MOVE (PS)+,D0 ; pop code address JMP 0(BP,D0.W) ; execute & return DC.B 8,'MCO' ; "mcompile" ( cfa -- ) DC.W Execute-theLink ; compile subroutine bodies inline MComp: MOVE (PS)+,D0 LEA 0(BP,D0.W),A0 ; addr of word @0: MOVE (A0)+,D0 CMPI #$4E75,D0 ; if its an RTS your done BEQ.S @1 MOVE D0,(A2)+ ; if not, compile it BRA.S @0 ; do next word @1: RTS DC.B 128+9,'[CO' ; "[compile]" ( -- ) compile DC.W mcomp-theLink ; the next immediate word bCompile: JSR tick-base(BP) ; get the cfa of the next word bra.s compile ; and compile a JSR to it DC.B 7,'COM' ; "compile" ( cfa -- ) compile a DC.W bcompile-theLink ; call to the cfa on the stack COMPILE MOVE #$04EAB,(DP)+ ; compile "JSR d(A3)" BRA.S Comma ; compile displacement value DC.B 9,'IMM' ; "immediate" ( -- ) make the last DC.W compile-theLink ; word defined immediate IMMED BSET #7,0(BP,Dict.W) ; set immediate bit of most recent word RTS DC.B 5,'MAC' ; "macro" ( -- ) make the last DC.W immed-theLink ; word defined an inline macro marco: BSET #6,0(BP,Dict.W) ; set macro bit of most recent word RTS DC.B 1,':',0,0 ; ":" ( -- ) make a header for a DC.W marco-theLink ; word definition COLON JSR token-Base(BP) ; make header JSR header-base(BP) BRA.S rbrack ; enter compile mode DC.B 129,']',0,0 ; "]" ( -- ) enter compile mode DC.W colon-theLink rBrack: BSET #7,fcolon-base(BP) ; set colon flag RTS DC.B 129,';',0,0 ; ";" ( -- ) end a word definition DC.W rBrack-theLink SEMI MOVE #$4E75,(DP)+ ; compile "RTS" BRA.S lbrack DC.B 129,'[',0,0 ; "[" ( -- ) leave compile mode DC.W semi-theLink lBrack: CLR.B fcolon-base(BP) ; clear colon flag RTS DC.B 7,'LIT' ; "literal" compiling: ( n -- ) DC.W lBrack-theLink ; executing: ( -- n ) LITERAL MOVE #$03D3C,(DP)+ ; compile move #xxxx,-(PS) BRA.S Comma ; compile constant DC.B 64+1,',',0,0 ; "," ( n -- ) DC.W literal-theLink COMMA MOVE (PS)+,(DP)+ ; pop number to dictionary RTS DC.B 8,'FLI' ; FLITERAL ( comp: n5 n4 n3 n2 n1 -- |exec: -- n5 n4 n3 n2 n1 ) DC.W comma-theLink flit: MOVE (PS),D0 MOVE 2(PS),D1 MOVE 8(PS),(PS) MOVE 6(PS),2(PS) MOVE D0,8(PS) MOVE D1,6(PS) MOVEQ #4,D0 @0: bsr.s literal DBRA D0,@0 RTS DC.B 128+2,',$',0 ; ",$" ( -- ) DC.W flit-theLink ; compile a hex number from input CommaH: MOVE NBase-base(BP),-(RS) MOVE #$10,nbase-base(BP) JSR token-base(BP) BSR.S here JSR number-base(BP) MOVE (RS)+,nbase-base(BP) TST (PS)+ BEQ whazat BRA.S comma DC.B 4,'HER' ; "here" ( -- addr ) DC.W commah-theLink ; rel.addr of compile point here: MOVE.L DP,-(PS) BRA.S torel DC.B 8,'DLI' ; "dliteral" compiling: ( d -- ) DC.W here-theLink ; executing: ( -- d ) DLit: MOVE #$2D3C,(DP)+ ; compile move.l #xxxx,-(PS) MOVE.L (PS)+,(DP)+ ; compile double number RTS DC.B 4,'>RE' ; ">rel" (to-rel) ( rel.uu) (rel.ah) DC.W dlit-theLink ; ( daddr32 -- addr16 ) toRel: MOVE.L (PS)+,D0 ; get the Daddr32 from stack SUB.L BP,D0 ; get difference from base addr MOVE D0,-(PS) ; push the 16 bit part of it RTS DC.B 5,'COU' ; "count" ( addr -- addr+1 length ) DC.W torel-theLink Count: CLR D1 MOVE (PS),D0 MOVE.B 0(BP,D0.W),D1 ADDQ #1,(PS) MOVE D1,-(PS) RTS DC.B 64+3,'+MD' ; "+MD" ( offset -- addr ) DC.W count-theLink MacDat: ADDI #theWindow-base,(PS) ; add data addr to stacked offset RTS DC.B 4,'PAG' ; "page" ( -- ) DC.W macdat-theLink ; clear the window Page: PEA WContRect-base(BP) ; The visable part of the window. _EraseRect MOVE.l #$90001,-(SP) _MoveTo ; set pen position to home (1,9) _PenNormal ; 1X1, black, patcopy MOVE.l #$40000,-(SP) _TextFont ; Monaco _TextFace ; plain text MOVE.l #$90000,-(SP) _TextSize ; 9 point _TextMode ; srcCopy RTS DC.B 4,'BEE' ; "beep" ( -- ) DC.W page-theLink Beep: MOVE.W #3,-(SP) _SysBeep RTS DC.B 64+3,'MON' ; "mon" ( -- ) execute _Debugger DC.W beep-theLink Mon: _DeBugger RTS TexD: DC.W 'TEXT' DC.B 4,'OPE' ; "open" ( -- ) DC.W mon-theLink Open: MOVE.L #$4B0037,-(SP) ; point: 75,55 CLR.L -(SP) ; no prompt CLR.L -(SP) ; no filter MOVE #1,-(SP) ; 1 type PEA texd-base(BP) CLR.L -(SP) ; no hook PEA (A2) ; put sfreply at here MOVE #2,-(SP) _Pack3 TST (A2) ; check 'good' field BEQ.S beep ; beep if cancel MOVE 6(A2),-(PS) ; hold the vrefnum on stack CLR D0 @0: MOVE.L 10(A2,D0.W),0(A2,D0.W) ; move the file name to 'here' ADDQ #4,D0 CMP #32,D0 BLE.S @0 BRA.S load1 DC.B 3,'-->' ; "-->" ( -- ) DC.W open-theLink Load: JSR token-base(BP) ; put filename string at here CLR -(PS) ; set vrefnum to 0 (path is specified) load1: MOVE fsptr-base(BP),D0 ; get file stack pointer BMI @0 ; ... save the offset into text ... LEA fofsets-base(BP),A0 ; ... at fofsets+fspointer MOVE.L TextO-base(BP),0(A0,D0) LEA fends-base(BP),A0 ; TextE at fends+fspointer MOVE.L TextE-base(BP),0(A0,D0) @0: ADDQ #4,fsptr-base(BP) ; increment the file stack pointer MOVE.L #80,D0 ; create an 80 byte block for DC.W $A31E ; _NewPtr ,CLEAR - the file control buffer MOVE.L A0,A4 ; save it for later MOVE.B #1,27(A0) ; set read only permission MOVE.L DP,18(A0) ; set name pointer MOVE (PS)+,22(A0) ; set vrefnum (working directory) DC.W $A100 ; _HOpen the file TST 16(A0) BNE.S derror _GetEOF ; get ... MOVE.L 28(A0),36(A0) ; ... and set ... MOVE.L 28(A0),-(PS) ; ... and hold the file size MOVE.L (PS),D0 ; set block size = file size _NewHandle BMI.S derror MOVE fsptr-base(BP),D0 ; get file stack pointer LEA fstack-base(BP),A1 ; file stack address MOVE.L A0,0(A1,D0.W) ; stash the handle at fstack+(fsptr) _HLock MOVE.L (A0),A0 ; get start addr of block MOVE.L A0,TextO-base(BP) ; set buffer start MOVE.L A0,D0 ; set buffer end ... ADD.L (PS)+,D0 MOVE.L D0,TextE-base(BP) ; ... to start + size MOVE.L A4,A0 MOVE.L TextO-base(BP),32(A0) ; set read buffer addr in fcb _Read ; read data from file ... TST 16(A0) ; ... to scrap buffer BNE derror _Close _DisposPtr JMP go-base(BP) ; interpret scrap buffer DError: MOVE 16(A0),-(PS) _Close _DisposPtr JSR pquote-base(BP) DC.B 10,'I/O Error:',0 ; print the error messsage JSR dot-base(BP) ; report the error number JMP huh-base(BP) DC.B 8,'?GE' ; "?GESTALT" DC.W load-theLink ; ( d.selector -- d.response true or false ) QGestalt: ; false if 64K ROM or no _Gestalt or bad selector ; check for 64K ROM MOVE #$A86E,D0 ; _InitGraf _GetTrapAddress.newTool MOVE.L A0,D1 MOVE #$AA6E,D0 ; _InitGraf AND $200 _GetTrapAddress.newTool CMP.L A0,D1 BEQ.S gser1 ; 64KROM ; Check for gestalt MOVE.W #$A89F,D0 ; _Unimplemented _GetTrapAddress.newTool ; NGetTrapAddress MOVE.L A0,D1 MOVE.W #$A1AD,D0 ; _Gestalt _GetTrapAddress.newOS ; NGetTrapAddress CMP.L A0,D1 BEQ.S gser1 ; no gestalt ; run gestalt MOVE.L (PS)+,D0 _Gestalt BNE.S gser2 MOVE.L A0,-(PS) ; return the result ... and ... MOVE #-1,-(PS) ; return true gsret: RTS gser1: ADDQ.L #4,PS ; gestalt error gser2: CLR -(PS) ; return false RTS DC.B 128+2,',S',0 ; ",S" compile a dnumber from ascii DC.W qgestalt-theLink ; NOTE: 1 and only 1 space seperates CommaS: ; move.l (is)+,-(ps) ; this word from its data. MOVE.L A2,A0 MOVEQ #4,D0 @0: MOVE.B (IS)+,(A0)+ DBRA D0,@0 MOVE.L (A2),-(PS) TST.B fcolon-base(BP) BEQ.S gsret JMP dlit-base(BP) DC.B 64+9,'INT' ; "interpret" ( -- ) DC.W commas-theLink Interp: JMP main-base(BP) RTS GRet: LEA Bottom,BP ; reset the base pointer LEA 0(BP,D1.W),DP ; abs.addr into register LEA 0(BP,D2.W),IS JSR toabs-base(BP) MOVE.L (PS)+,(RS) RTS DC.B 4,'GRO' ; "grow" ( bytes -- ) DC.W interp-theLink ; enlarge the dictionary headroom Grow: JSR here-base(BP) MOVE (PS)+,D1 ; hold rel DP in D1 MOVE.L IS,-(PS) JSR torel-base(BP) MOVE (PS)+,D2 MOVE.L (RS),-(PS) JSR torel-base(BP) JSR swapp-base(BP) MOVEA.L expand-base(BP),A0 JMP (A0) ; JSR won't return here DC.B 4,'ROO' ; "room" ( -- bytes ) DC.W grow-theLink Room: LEA Bottom,A0 ; version 3+ use (PC) addressing _RecoverHandle ; use handle rather than pointer _GetHandleSize LEA Bottom,A0 ; Bottom ... version 3+ use (PC) addressing ADDA.L D0,A0 ; + block size ... SUBA.L A2,A0 ; - end of dictionary MOVE A0,-(PS) ; = unused dictionary space RTS DC.B 4,'SAV' ; "save" ( -- ) save the dictionary DC.W room-theLink Save: JSR here-base(BP) MOVE (PS)+,freePt-base(BP) ; save current DP MOVE Dict,DictPt-base(BP) ; save current DictPt BSR.S room MOVE (PS),freesz-base(BP) ; save current headroom JSR negate-base(BP) BSR.S grow ; reduce headroom to 4 bytes LEA Bottom,A0 ; version 3+ use (PC) addressing _RecoverHandle ; get DICT's handle CLR -(SP) MOVE.L A0,-(SP) ; push 2, 1 for each operation MOVE.L A0,-(SP) _ChangedResource _HomeResFile _UpdateResFile ; write out the DICT MOVE freesz-base(BP),-(PS) BRA.S grow ; restore headroom DC.B 4,'>AB' ; ">abs" (to-abs) DC.W save-theLink ; ( addr16 -- daddr32 ) toAbs: CLR.L D0 MOVE (PS)+,D0 ; pop rel addr LEA 0(BP,D0.W),A0 ; calc as offset to base ... MOVE.L A0,-(PS) ; ... and push RTS DC.B 64+6,'NEG' ; "negate" ( n -- -n ) DC.W toabs-theLink negate: NEG (PS) RTS DC.B 5,'SPA' ; "space" ( -- ) emit a space DC.W negate-theLink space: MOVE.L #32,D0 jmp EmitCode-Base(BP) DC.B 4,'TYP' ; "type" ( rel.addr len -- ) DC.W space-theLink ; emit len characters from rel.addr Type: MOVEM.L D3/D4,-(SP) ; don't trash registers! MOVE (PS)+,D3 ; get character count SUBQ #1,D3 ; ( fixed bug ) MOVE (PS)+,D4 ; get string relative address @0: MOVE.B 0(BP,D4.W),D0 ; get character byte jsr EmitCode-Base(BP) ; print character byte ADDQ #1,D4 DBRA D3,@0 MOVEM.L (SP)+,D3/D4 ; restore registers rts pQuote: ; runtime part of ." MOVE.L (RS),-(PS) ; push the addr of the string JSR torel-base(BP) ADDQ #1,(PS) ; skip the length byte MOVE.L (RS),A0 CLR.L D0 ; clear the character count MOVE.B (A0),D0 ; get the length MOVE D0,-(PS) ; push it ADDQ #2,D0 ANDI #$FFFE,D0 ; be sure its even ADD.L D0,(RS) ; skip over string upon return bra.s type ;-base(BP) ; type the string DC.B 4,'EMI' ; "emit" ( n -- ) send the ascii DC.W type-theLink ; to the terminal Emit: MOVE (PS)+,D0 EmitCode: ; Emit contents of D0 CMP.B #13,D0 ; is it a <cr> BEQ.S doCR CMP.B #8,D0 ; is it a <del>? BEQ.S doDEL ANDI #$FF,D0 MOVE D0,-(A7) _DrawChar BSR.S penh MOVE WContRect+6-base(BP),D0 ; right coord of WContRect CMP D0,D1 ; is the position beyond the edge BLS.S emitr ; no doCR: PEA Scratch-base(BP) _GetPen MOVE Scratch-base(BP),D1 MOVE WContRect+4-base(BP),D0 ; bottom coord of WContRect SUB #11,D0 CMP D0,D1 ; is the position below the window BLS.S @0 ; no ; yes it is below the bottom of the window, so scroll up 11 pixels CLR.L -(A7) ; Make room for a region handle. _NewRgn ; get handle into (A7) PEA WContRect-base(BP) ; rect to scroll CLR -(A7) ; no horiz. MOVE #$FFF5,-(A7) ; 11 pix. vert. MOVE.L 8(A7),-(A7) ; push the region handle _ScrollRect _DisposRgn MOVE WContRect+4-base(BP),D1 ; bottom coord of WContRect SUBQ #4,D1 BRA.S @1 @0: ADD #11,D1 ; Add line height to pen location @1: MOVE #1,-(A7) MOVE D1,-(A7) _MoveTo emitr: RTS doDEL: BSR.S penh CMP #6,D1 ; first column? blt.s @0 ; don't beep anymore SUB #6,D1 ; back up MOVE D1,-(SP) MOVE Scratch-base(BP),-(SP) _MoveTo @0: RTS penh: PEA Scratch-base(BP) _GetPen MOVE Scratch+2-base(BP),D1 RTS DC.B 6,'EXP' ; "expect" ( addr count -- ) DC.W emit-theLink Expect: MOVEM.L D4/IS,-(SP) JSR swapp-base(BP) ; leave number of chars on stack MOVE (PS)+,D0 ; addr LEA 0(BP,D0.W),IS ; set IS to the input address CLR Counter MOVE (PS)+,D4 @0: JSR key-base(BP) MOVE (PS)+,D5 CMPI #CR,D5 ; if key = CR BNE.S @1 MOVE.B #BL,0(IS,Counter) CLR.B 1(IS,Counter) MOVE.B #BL,2(IS,Counter) BRA.S @3 @1: CMPI #BS,D5 ; if key = backspace BNE.S @2 TST Counter ; do nothing if first key is BS BEQ.S @0 SUBQ #1,Counter ; decriment counter JSR dodel-base(BP) JSR space-base(BP) ; ... rubout char JSR dodel-base(BP) BRA.S @0 @2: MOVE.B D5,0(IS,Counter) ; stash the key into input buffer ADDQ #1,Counter MOVE D5,D0 JSR emitcode-base(BP) CMP D4,Counter ; is count=number of chars to get? BNE.S @0 @3: JSR docr-base(BP) MOVEM.L (SP)+,D4/IS RTS DC.B 64+1,'0',0,0 ; "0" ( -- 0 ) DC.W expect-theLink Zero: CLR -(PS) RTS DC.B 64+4,'DRO' ; "drop" ( n -- ) DC.W zero-theLink drop: ADDQ.L #2,PS RTS DC.B 4,'SWA' ; "swap" ( n1 n2 -- n2 n1 ) DC.W drop-theLink swapp: MOVE.L (PS)+,D0 SWAP D0 MOVE.L D0,-(PS) RTS DC.B 64+5,'2DR' ; "2drop" ( d -- ) DC.W swapp-theLink TwoDrop: ADDQ.L #4,PS RTS DC.B 4,'NUL' ; "null" ( -- ) DC.W twodrop-theLink Null: RTS DC.B 6,'FOR' ; "forget" ( -- ) forgets dictionary DC.W null-theLink Forget: JSR tick-base(BP) MOVE (PS)+,D0 MOVE -2(BP,D0.W),Dict LEA -6(BP,D0.W),DP RTS DC.B 8,'CON' ; "constant" compile: ( n16 -- ) DC.W forget-theLink ; runtime: ( -- n16 ) Const: JSR token-base(BP) ; make a header for the next token JSR header-base(BP) JSR marco-base(BP) ; to return a constant JSR literal-base(BP) ; compile time comma, runtime push MOVE #$4E75,(DP)+ ; compile rts RTS DC.B 6,'CRE' ; "create" compile: ( -- ) DC.W const-theLink ; runtime: ( -- addr16 ) Create: JSR token-base(BP) ; give token this runtime action: JSR header-base(BP) MOVE #$3D3C,(DP)+ ; • move #nnnn,-(ps) JSR here-base(BP) ADDQ #6,(PS) MOVE (PS)+,(DP)+ ; supply the nnnn from above MOVE #$4EEB,(DP)+ ; • jmp null-base(bp) MOVE.L DP,DoesAddr-base(BP) ; set DoesAddr to this "null" MOVE #null-base,(DP)+ RTS DC.B 5,'DOE' ; "does>" ( -- ) (use after create) DC.W create-theLink ; set runtime action Does: MOVE.L (RS)+,D0 ; pop the return address SUB.L BP,D0 ; convert to rel.addr MOVE.L DoesAddr-base(BP),A0 ; load jmp d(bp) address from create MOVE D0,(A0) ; and stash rel.addr into it RTS ; returns same as ; DC.B 5,'ALL' ; "allot" ( n16 -- ) DC.W does-theLink ; compiles nada into the dictionary Allot: ADDQ #1,(PS) ANDI #$FFFE,(PS) ; make it even! ADDA (PS)+,DP ; increment the dictionary pointer RTS DC.B 8,'VAR' ; "variable" compile: ( -- ) DC.W allot-theLink ; runtime: ( -- addr16 ) Variable: JSR token-base(BP) ; give token this runtime action: JSR header-base(BP) JSR marco-base(BP) ; Sun May 1, 1988 04:24:44 MOVE #$3D3C,(DP)+ ; • move #nnnn,-(ps) JSR here-base(BP) ADDQ #4,(PS) ; calculate nnnn MOVE (PS)+,(DP)+ ; • (this is the nnnn) MOVE #$4E75,(DP)+ ; • rts ADDQ.L #2,DP ; 2 allot RTS DC.B 64+5,'>NA' ; ">name" ( 'addr -- name.addr ) DC.W variable-theLink toname: SUBQ #6,(PS) RTS DC.B 64+5,'>LI' ; ">link" ( 'addr -- link.addr ) DC.W toname-theLink tolink: SUBQ #2,(PS) RTS DC.B 3,'ID.' ; "id." ( addr -- ) DC.W tolink-theLink IDDot: JSR toname-base(BP) MOVEA.L DP,A0 MOVEQ.L #5,D0 @0: MOVE.L #$C9C9C9C9,(A0)+ DBRA D0,@0 MOVE (PS)+,D0 MOVE.L 0(BP,D0.W),(DP) JSR here-base(BP) MOVE (PS),-(PS) JSR cat-base(BP) ANDI #$1F,(PS) ; look at 5 lsb's ADDQ #1,2(PS) JSR type-base(BP) JMP space-base(BP) DC.B 5,'WOR' ; "words" ( -- ) list words DC.W iddot-theLink Words: MOVE.L D3,-(SP) ; preserve register MOVE Dict,D3 ; start with the last word defined @0: MOVE D3,-(PS) ; push the name address ADDQ #6,(PS) ; get the CFA BSR.S iddot ; print the name MOVE 4(BP,D3.W),D3 ; put the next name addr into D3 TST.B 1(BP,D3.W) ; Quit if name is 0 BEQ.S @1 ; do next word if not=0 JSR qterm-base(BP) TST (PS)+ BEQ.S @0 @1: MOVE.L (SP)+,D3 ; restore register RTS DC.B 3,'PAD' ; "pad" ( -- ) conversion pad DC.W words-theLink Pad: JSR here-base(BP) ADDI #40,(PS) ; pad is 40 bytes from HERE. RTS DC.B 4,'HOL' ; "hold" ( c -- ) place c at ... DC.W pad-theLink ; ... addr in Held. Hold: SUBQ #1,held-base(BP) MOVE held-base(BP),-(PS) JMP cstore-base(BP) DC.B 4,'SIG' ; "sign" ( sf dval -- dval ) DC.W hold-theLink Sign: JSR rote-base(BP) TST (PS)+ BGE.S @0 MOVE #'-',-(PS) BSR.S hold @0: RTS DC.B 4,'DAB' ; "dabs" ( dval -- |dval| ) DC.W sign-theLink Dabs: TST (PS) BGE.S @0 JSR dneg-base(BP) @0: RTS DC.B 2,'<#',0 ; "<#" ( -- ) DC.W dabs-theLink LSharp: BSR.S pad MOVE (PS)+,held-base(BP) MOVEA.L DP,A0 MOVE #9,D0 @0: CLR.L (A0)+ DBRA D0,@0 MOVE #30,-(PS) BRA.S hold DC.B 2,'#>'.0 ; "#>" ( dval -- addr len ) DC.W lsharp-theLink SharpG: ADDQ.L #2,PS MOVE held-base(BP),(PS) BSR.S pad MOVE 2(PS),-(PS) ; over ADDQ #1,(PS) JMP minus-base(BP) DC.B 1,'#',0,0 ; "#" ( dval -- d/base ) DC.W sharpg-theLink Sharp: MOVE NBase-base(BP),-(PS) JSR msmod-base(BP) JSR rote-base(BP) CMPI #9,(PS) ; is top of stack < 9? BLE.S @0 ADDQ #7,(PS) @0: ADDI #48,(PS) JMP hold-base(BP) DC.B 2,'#S',0 ; "#s" ( dval -- 0 0 ) DC.W sharp-theLink Sharps: BSR.S sharp TST.L (PS) BNE.S sharps RTS DC.B 2,'D.',0 ; "d." ( dval -- ) DC.W sharps-theLink DDot: JSR swapp-base(BP) MOVE 2(PS),-(PS) JSR dabs-base(BP) BSR.S lsharp BSR.S sharps JSR sign-base(BP) BSR.S sharpg jsr type-base(BP) jmp space-base(bp) DC.B 2,'U.',0 ; "u." ( uval -- ) DC.W ddot-theLink UDot: CLR -(PS) BRA.S ddot DC.B 3,'S>D' ; "s>d" ( n -- d ) DC.W udot-theLink SToD: MOVE (PS),-(PS) ; dup JMP zerolt-base(BP) ; 0< DC.B 1,'.',0,0 ; "." ( n -- ) DC.W stod-theLink Dot: BSR.S stod BRA.S ddot DC.B 130,'."',0 ; "."" ( -- ) compiler part of (.") DC.W dot-theLink dotQ: MOVE #pQuote-base,-(PS) JSR compile-base(BP) ; compile a call to (.") JSR here-base(BP) ; ( -- addr ) MOVE #'"',-(PS) ; ( -- addr 34 ) JSR word-base(BP) ; ( -- addr ) JSR cat-base(BP) ; ( -- c ) ADDQ #1,(PS) ; ( -- c+1 ) JMP allot-base(BP) ; enclose the string in dictionary DC.B 129,'(',0,0 ; "(" ( -- ) begin comment DC.W dotq-theLink Comment CMPI.B #41,(IS)+ ; read in characters until ")" BNE.S Comment RTS DC.B 5,'CMO' ; "cmove" ( addr1 addr2 len -- ) DC.W comment-theLink ; from figFORTH, fixed 8/3/91 CMove: MOVE (PS)+,D0 ; D0 = length MOVE (PS)+,D1 LEA 0(BP,D1.W),A1 ; A1 = addr2 MOVE (PS)+,D1 LEA 0(BP,D1.W),A0 ; A0 = addr1 CMPA.L A0,A1 BPL.S @2 BRA.S @1 ; addr1 > addr2 @0: MOVE.B (A0)+,(A1)+ @1: DBRA D0,@0 RTS @2: ADDA D0,A0 ; addr1 ≤ addr2 ADDA D0,A1 BRA.S @4 @3: MOVE.B -(A0),-(A1) @4: DBRA D0,@3 RTS DC.B 4,'FIL' ; "fill" ( addr count char -- ) DC.W cmove-theLink Fill: MOVE (PS)+,D0 ; character MOVE (PS)+,D1 ; count SUBQ #1,D1 ; decrement count MOVE (PS)+,A0 ; relative addr LEA 0(BP,A0.W),A0 ; get absolute addr @0: MOVE.B D0,0(A0,D1.W) ; put char into addr + count DBRA D1,@0 ; decrement count & loop until 0 RTS DC.B 9,'-TR' ; "-trailing" DC.W fill-theLink ; ( addr count -- addr new.count ) dtrail: MOVE (PS)+,D1 ; get the count MOVE (PS),D0 ; get the rel.addr LEA 0(BP,D0.W),A0 ; get the abs.addr @0: CMPI.B #$20,-1(A0,D1.W) ; BEGIN is char at addr+count $20 DBNE D1,@0 ; NOT UNTIL MOVE D1,-(PS) ; put new count on stack RTS DC.B 64+2,'1+',0 ; "1+" ( n -- n+1 ) DC.W dtrail-theLink OnePl: ADDQ #1,(PS) RTS DC.B 64+2,'1-',0 ; "1-" ( n -- n-1 ) DC.W onepl-theLink OneMi: SUBQ #1,(PS) RTS DC.B 64+2,'2+',0 ; "2+" ( n -- n+2 ) DC.W onemi-theLink TwoPl: ADDQ #2,(PS) RTS DC.B 64+2,'2*',0 ; "2*" ( n -- n*2 ) DC.W twopl-theLink ToStar: ASL (PS) RTS DC.B 64+2,'2/',0 ; "2/" ( n -- n/2 ) DC.W tostar-theLink ToDiv: ASR (PS) RTS DC.B 5,'DEP' ; "depth" ( -- n ) DC.W ToDiv-theLink ; 16 bit entries on stack before this depth: move.l szero-base(bp),d0 sub.l ps,d0 move d0,-(ps) bra.s todiv DC.B 1,'@',0,0 ; "@" (at) ( addr16 -- n16 ) DC.W depth-theLink At: MOVE (PS),D0 ; DANGER: odd values crash this MOVE 0(BP,D0.W),(PS) RTS DC.B 1,'!',0,0 ; "!" (store) ( n16 addr16 -- ) DC.W at-theLink Store: MOVE (PS)+,D0 ; DANGER: odd values crash this MOVE (PS)+,0(BP,D0.W) RTS DC.B 2,'C!',0 ; "c!" (sea-store)( n8 addr16 -- ) DC.W store-theLink CStore: MOVE (PS)+,D0 ; get the rel.addr (odd OK) ADDQ.L #1,PS ; align the stack MOVE.B (PS)+,0(BP,D0.W) ; put data at the addr RTS DC.B 2,'C@',0 ; "c@" (sea-at) ( addr16 -- n8 ) DC.W cstore-theLink CAt: MOVE (PS),D0 ; get rel.addr (odd OK) CLR (PS) ; clear the result MOVE.B 0(BP,D0.W),1(PS) ; stash the second byte RTS DC.B 64+2,'L@',0 ; "l@" (el-at) ( daddr32 -- n16 ) DC.W cat-theLink LAt: MOVEA.L (PS)+,A0 ; get the double number "real" addr MOVE (A0),-(PS) ; fetch the contents RTS DC.B 64+2,'L!',0 ; "l!" (el-store)( n16 daddr32 -- ) DC.W lat-theLink LStore: MOVEA.L (PS)+,A0 MOVE (PS)+,(A0) RTS DC.B 64+3,'DL@' ; "dl@" ( daddr32 -- d32 ) DC.W lstore-theLink DLAt: MOVEA.L (PS),A0 MOVE.L (A0),(PS) RTS DC.B 64+3,'DL!' ; "dl!" ( d32 daddr32 -- ) DC.W dlat-theLink DLStor: MOVE.L (PS)+,A0 MOVE.L (PS)+,(A0) RTS DC.B 2,'+!',0 ; "+!" ( n16 addr16 -- ) DC.W dlstor-theLink pstore: MOVE (PS)+,D0 MOVE (PS)+,D1 ADD D1,0(BP,D0.W) RTS DC.B 64+4,'CBL' ; "cblk" ( -- addr ) of fint DC.W pstore-theLink cBLK: MOVE #fint-base,-(PS) RTS DC.B 64+6,'CST' ; "cstate" ( -- addr ) of fcolon DC.W cblk-theLink cState: MOVE #fcolon-base,-(PS) RTS DC.B 64+4,'BAS' ; "base" ( -- addr ) DC.W cstate-theLink ; variable for the numeric radix BaseA: MOVE #nbase-base,-(PS) RTS DC.B 64+3,'TIB' ; "tib" ( -- addr ) DC.W basea-theLink ; variable for Terminal Input Buf. TIB: MOVE #termbuf-base,-(PS) RTS DC.B 64+6,'LAT' ; "latest" ( -- addr ) DC.W tib-theLink ; variable for the last dict word Latest: MOVE Dict,-(PS) ; push contents of the dict register RTS DC.B 64+3,'R0@' ; "r0@" ( -- dabs.addr ) DC.W latest-theLink ; dabs.addr of r0 R0at: MOVE.L rzero-base(BP),-(PS) RTS DC.B 64+3,'RP@' ; "rp@" ( -- dabs.addr ) DC.W r0at-theLink ; current addr of the return stack RPat: MOVE.L RS,-(PS) RTS DC.B 64+3,'S0@' ; "s0@" ( -- dabs.addr ) DC.W rpat-theLink ; dabs.addr of s0 S0at: MOVE.L szero-base(BP),-(PS) RTS DC.B 64+3,'SP@' ; "sp@" ( -- dabs.addr ) DC.W s0at-theLink ; address of the current stack cell SPat: MOVE.L PS,-(PS) RTS DC.B 3,'HEX' ; "hex" ( -- ) DC.W spat-theLink hex: MOVE #$10,nbase-base(BP) RTS DC.B 7,'DEC' ; "decimal" ( -- ) DC.W hex-theLink decimal MOVE #10,nbase-base(BP) RTS DC.B 4,'?DU' ; "?dup" ( n -- n n OR n [if n=0] ) DC.W decimal-theLink qdup: TST (PS) BNE.S dup RTS DC.B 64+3,'DUP' ; "dup" ( n -- n n ) DC.W qdup-thelink dup: MOVE (PS),-(PS) RTS DC.B 64+4,'OVE' ; "over" ( n1 n2 -- n1 n2 n1 ) DC.W dup-theLink over: MOVE 2(PS),-(PS) RTS DC.B 3,'ROT' ; "rot" ( n1 n2 n3 -- n2 n3 n1 ) DC.W over-theLink rote: MOVE.L (PS)+,D0 MOVE (PS)+,D1 MOVE.L D0,-(PS) MOVE D1,-(PS) RTS DC.B 64+4,'2DU' ; "2dup" ( n1 n2 -- n1 n2 n1 n2 ) DC.W rote-theLink todup: MOVE.L (PS),-(PS) RTS DC.B 5,'2SW' ; "2swap" DC.W todup-theLink ; ( n1 n2 n3 n4 -- n3 n4 n1 n2 ) toswap: MOVE.L (PS)+,D0 MOVE.L (PS)+,D1 MOVE.L D0,-(PS) MOVE.L D1,-(PS) RTS DC.B 64+2,'>R',0 ; ">r" ( n -- ) rstack: ( -- n16 ) DC.W toswap-theLink toR: MOVE (PS)+,-(RS) RTS DC.B 64+2,'R>',0 ; "r>" ( -- n ) rstack: ( n16 -- ) DC.W tor-theLink Rfrom: MOVE (RS)+,-(PS) RTS DC.B 64+1,'R',0,0 ; "r" ( -- n ) rs: ( n16 -- n16 ) DC.W rfrom-theLink Are: MOVE (RS),-(PS) RTS DC.B 4,'EXI' ; "exit" ( -- ) drops return address DC.W are-theLink Exit: ADDQ.L #4,RS RTS DC.B 1,'*',0,0 ; "*" ( n1 n2 -- n1*n2 ) DC.W exit-theLink times: MOVE (PS)+,D0 MULS (PS)+,D0 MOVE D0,-(PS) RTS DC.B 4,'/MO' ; "/mod ( n1 n2 -- rem quot ) DC.W times-theLink Smod: MOVE (PS)+,D0 BNE.S @0 BRA.S sfail @0: MOVE (PS)+,D1 EXT.L D1 DIVS D0,D1 SWAP D1 MOVE.L D1,-(PS) RTS DC.B 1,'/',0,0 ; "/" ( n1 n2 -- quotient ) DC.W smod-theLink Slash: JSR smod-base(BP) JSR swapp-base(BP) ADDQ.L #2,PS RTS DC.B 3,'MOD' ; "mod" ( n1 n2 -- remainder ) DC.W slash-theLink mod: JSR smod-base(BP) ADDQ.L #2,PS RTS DC.B 2,'*/',0 ; "*/" ( n1 n2 n3 -- n1*n2/n3 ) DC.W mod-theLink SSlash: MOVE (PS)+,D1 BNE.S sok ADDQ.L #2,PS sfail: MOVE #-1,(PS) RTS sok: MOVE (PS)+,D0 MULS (PS),D0 DIVS D1,D0 MOVE D0,(PS) RTS DC.B 2,'U*',0 ; "u*" ( n1 n2 -- d32 ) DC.W sslash-theLink UStar: MOVE (PS)+,D0 MULU (PS)+,D0 MOVE.L D0,-(PS) RTS DC.B 5,'M/M' ; "m/mod" from King&Knight DC.W ustar-theLink ; ( num32 denom16 -- rem16 quot32 ) MSMod: TST (PS) ; test for div by zero BNE.S @0 ADDQ.L #4,PS BRA.S sfail @0: MOVE.L D2,-(SP) ; save D2 MOVEQ #0,D2 ; clear it MOVE (PS)+,D2 ; pop denom into D2.W MOVE.L (PS)+,D1 ; pop num into D1.L MOVE D1,-(SP) ; hold num.l on rstack CLR D1 SWAP D1 DIVU D2,D1 MOVE D1,D0 MOVE (SP)+,D1 DIVU D2,D1 SWAP D1 MOVE D1,-(PS) ; push remainder MOVE D0,D1 SWAP D1 MOVE.L D1,-(PS) ; push quotient MOVE.L (SP)+,D2 ; restore register RTS DC.B 64+7,'DNE' ; "dnegate" ( d32 -- -d32 ) DC.W msmod-theLink DNeg: NEG.L (PS) RTS DC.B 64+2,'D+',0 ; "d+" ( d1 d2 -- d1+d2 ) DC.W dneg-theLink DPlus: MOVE.L (PS)+,D0 ADD.L D0,(PS) RTS DC.B 128+2,'IF',0 ; "if" ( flag -- ) at runtime DC.W dplus-theLink ; ( -- addr ) at compile time pIf: MOVE.L #$4A5E6700,(DP)+ ; compile tst (ps)+ beq ... pi1: bsr.s pbegin ADDQ.L #2,DP ; make room for offset RTS DC.B 128+5,'WHI' ; "while" ( flag -- ) at runtime DC.W pif-theLink ; ( -- addr ) at compile time pWhile: BRA.S pIf DC.B 128+4,'ELS' ; "else" ( -- ) at runtime DC.W pwhile-theLink ; ( addr -- addr ) at compile time pElse: MOVE #$6000,(DP)+ bsr.s pi1 JSR swapp-base(BP) BRA.S pthen DC.B 128+4,'THE' ; "then" ( -- ) at runtime DC.W pelse-theLink ; ( addr -- ) at compile time pThen: bsr.s pbegin MOVE 2(PS),-(PS) ; over JSR minus-base(BP) JSR swapp-base(BP) JMP store-base(BP) DC.B 128+6,'REP' ; "repeat" ( -- ) at runtime DC.W pthen-theLink ; ( b.addr w.addr -- ) at c.time pRepet: MOVE #$6000,(DP)+ ; compile bra ... JSR swapp-base(BP) BSR.S back BRA.S pThen ; HERE OVER - SWAP ! ; DC.B 128+5,'BEG' ; "begin" ( -- ) at runtime DC.W prepet-theLink ; ( -- addr ) at compile time pBegin: JMP here-base(BP) DC.B 128+5,'UNT' ; "until" ( flag -- ) at runtime DC.W pbegin-theLink ; ( addr -- ) at compile time pUntil MOVE.L #$4A5E6700,(DP)+ ; compile tst (ps)+ beq ... BRA.S back DC.B 128+5,'AGA' ; "again" ( -- ) at runtime DC.W puntil-theLink ; ( addr -- ) at compile time pAgain: MOVE #$6000,(DP)+ ; compile bra ... BRA.S back DC.B 4,'BAC' ; "back" ( addr -- ) DC.W pagain-theLink ; compile negative displacement back: bsr.s pbegin JSR minus-base(BP) MOVE (PS),D0 ; get the target addr into d0 BGE.S @0 NEG D0 ; make it positive @0: ANDI #$FF80,D0 ; if > 1 byte BEQ.S @1 JMP comma-base(BP) ; then comma it as a long branch @1: MOVE.B 1(PS),-1(DP) ; else make it a short branch JMP drop-base(BP) DC.B 128+2,'DO',0 ; "do" ( -- addr ) at compile time DC.W back-theLink ; ( limit index -- ) at runtime do: MOVE #$2F1E,(DP)+ ; • move.l (ps)+,-(ps) bra.s pbegin DC.B 128+4,'LOO' ; "loop" ( -- ) at runtime DC.W do-theLink ; ( addr -- ) at compile time Loop: MOVE.L #$52573017,(DP)+ ; • addq #1,(rs) • move (rs),d0 (increment ix) MOVE.L #$B06F0002,(DP)+ ; • cmp 2(rs),d0 (check lim) MOVE #$6B00,(DP)+ ; • bmi ... (loop if ix<lim) pl: BSR.S back ; comma in the displacement to 'do' MOVE #$588F,(DP)+ ; • addq.l #4,rs (drop ix&lim) RTS DC.B 128+5,'+LO' ; "+loop" ( n -- ) at runtime DC.W loop-theLink ; ( addr -- ) at compile time pLoop: MOVE #$4EAB,(DP)+ MOVE #ppl-base,(DP)+ ; • jsr ppl-base(bp) MOVE #$6700,(DP)+ ; • beq ... (neg flag change) BRA.S pl ppl: MOVE 4(A7),D0 ; get index CMP 6(A7),D0 ; check limit MOVE SR,D1 ; hold result MOVE (PS)+,D0 ; get step ADD D0,4(A7) ; incerment index MOVE 4(A7),D0 ; get new index CMP 6(A7),D0 ; check new limit MOVE SR,D0 ; hold it EOR D0,D1 ; mix with last result AND #8,D1 ; check for change in neg flag RTS DC.B 5,'LEA' ; "leave" ( -- ) DC.W ploop-theLink ; set the index to the limit Leave: MOVE 6(RS),4(RS) RTS DC.B 2,'0<',0 ; "0<" ( n -- flag ) DC.W leave-theLink ZeroLT: TST (PS) BLT.S true false: CLR (PS) RTS true: MOVE #-1,(PS) RTS DC.B 2,'0>',0 ; "0>" ( n -- flag ) DC.W zerolt-theLink ZeroGT: NEG (PS) BRA.S zerolt DC.B 2,'0=',0 ; "0=" ( n -- flag ) DC.W zerogt-theLink ZeroEQ: TST (PS) BEQ.S true BRA.S false DC.B 64+1,'+',0,0 ; "+" ( n1 n2 -- n1+n2 ) DC.W zeroeq-theLink plus: MOVE (PS)+,D0 ADD D0,(PS) RTS DC.B 1,'-',0,0 ; "-" ( n1 n2 -- n1-n2 ) DC.W plus-theLink minus: NEG (PS) bra.s plus DC.B 1,'=',0,0 ; "=" ( n1 n2 -- flag ) DC.W minus-theLink equal: bsr.s minus BRA.S zeroeq DC.B 1,'<',0,0 ; "<" ( n1 n2 -- flag ) DC.W equal-theLink lesst: bsr.s minus BRA.S zerolt DC.B 1,'>',0,0 ; ">" ( n1 n2 -- flag ) DC.W lesst-theLink moret: bsr.s minus BRA.S zerogt DC.B 64+3,'AND' ; "and" ( n1 n2 -- n1(and)n2 ) DC.W moret-theLink andd: MOVE (PS)+,D0 AND D0,(PS) RTS DC.B 64+2,'OR',0 ; "or" ( n1 n2 -- n1(or)n2 ) DC.W andd-theLink orr: MOVE (PS)+,D0 OR D0,(PS) RTS DC.B 64+3,'XOR' ; "xor" ( n1 n2 -- n1(xor)n2 ) DC.W orr-theLink xor: MOVE (PS)+,D0 EOR D0,(PS) RTS DC.B 3,'ABS' ; "abs" ( n1 -- abs(n1) ) DC.W xor-theLink abs: TST (PS) BGE.S @0 NEG (PS) @0: RTS DC.B 3,'MIN' ; "min" ( n1 n2 -- n(min) ) DC.W abs-theLink min: MOVE (PS)+,D0 CMP (PS),D0 BLT.S pd0 RTS pd0: MOVE D0,(PS) RTS DC.B 3,'MAX' ; "max" ( n1 n2 -- n(max) ) DC.W min-theLink max: MOVE (PS)+,D0 CMP (PS),D0 BGE.S pd0 RTS DC.B 2,'2@',0 ; "2@" ( addr -- d ) DC.W max-theLink ; 32 bit fetch TwoAt: MOVE (PS)+,D0 MOVE.L 0(BP,D0.W),-(PS) RTS DC.B 2,'2!',0 ; "2!" ( d addr -- ) DC.W twoat-theLink ; 32 bit store TwoStore: MOVE (PS)+,D0 MOVE.L (PS)+,0(BP,D0.W) RTS DC.B 9,'2CO' ; "2constant" DC.W twostore-theLink ; defining: ( d -- ) TwoCon: JSR token-base(BP) ; executing: ( -- d ) JSR header-base(BP) JSR dlit-base(BP) MOVE #$4E75,(DP)+ RTS DC.B 9,'2VA' ; "2variable" DC.W twocon-theLink ; defining: ( -- ) TwoVar: JSR variable-base(BP) ; executing: ( -- addr ) ADDQ.L #2,DP RTS DC.B 64+3,'2>R' ; "2>r" ( d -- ) rstack: ( -- d ) DC.W twovar-theLink TwoToR: MOVE.L (PS)+,-(RS) RTS DC.B 64+3,'2R>' ; "2r>" ( -- d ) rstack: ( d -- ) DC.W twotor-theLink TwoRFrom: MOVE.L (RS)+,-(PS) RTS DC.B 3,'A>R' ; "a>r" ( addr -- ) DC.W tworfrom-theLink ; rstack: ( -- dabs.addr ) AToR: JSR toabs-base(BP) MOVE.L (SP)+,A0 MOVE.L (PS)+,-(SP) JMP (A0) DC.B 64+5,'2OV' ; "2over" ( d1 d2 -- d1 d2 d1 ) DC.W ator-theLink TwoOver: MOVE.L 4(PS),-(PS) RTS DC.B 4,'2RO' ; "2rot" ( d1 d2 d3 -- d2 d3 d1 ) DC.W twoover-theLink TwoRot: MOVE.L (PS)+,D0 MOVE.L (PS)+,D1 MOVE.L (PS),A0 MOVE.L D1,(PS) MOVE.L D0,-(PS) MOVE.L A0,-(PS) RTS ; floating point stack manipulation DC.B 64+5,'FDR' ; FDROP ( n1 n2 n3 n4 n5 -- ) DC.W tworot-theLink fdrop: ADDQ.L #6,PS ADDQ.L #4,PS RTS DC.B 4,'FDU' ; FDUP ( n5 n4 n3 n2 n1 -- n5 n4 n3 n2 n1 n5 n4 n3 n2 n1 ) DC.W fdrop-theLink fdup: LEA 10(PS),A0 MOVE.L -(A0),-(PS) MOVE.L -(A0),-(PS) MOVE.W -(A0),-(PS) RTS DC.B 5,'FSW' ; FSWAP ( f1 f2 -- f2 f1 ) DC.W fdup-theLink fswap: LEA (PS),A0 LEA 10(PS),A1 MOVEQ #4,D1 @0: MOVE (A1),D0 MOVE (A0),(A1)+ MOVE D0,(A0)+ DBRA D1,@0 RTS DC.B 5,'FPI' ; FPICK ( fn..f1 m|n≥m≥1 -- fn..f1 fm ) DC.W fswap-theLink fpick: MOVE #$0A,-(PS) JSR times-base(BP) MOVE (PS)+,D0 LEA 0(PS,D0.W),A0 MOVE.L -(A0),-(PS) MOVE.L -(A0),-(PS) MOVE -(A0),-(PS) RTS DC.B 5,'FPA' ; FPACK ( fn..f1 fnew m -- fn..f1 ) ( fm = fnew ) DC.W fpick-theLink fpack: MOVE #$0A,-(PS) JSR times-base(BP) MOVE (PS)+,D0 LEA 0(PS,D0.W),A0 MOVE.L (PS)+,(A0)+ MOVE.L (PS)+,(A0)+ MOVE (PS)+,(A0)+ RTS DC.B 5,'FRO' ; FROLL ( fn..f1 m -- fn..fm+1 fm-1..f1 fm ) DC.W fpack-theLink froll: bsr.s fpick LSR.W #1,D0 subq #1,d0 @0: MOVE -(A0),10(A0) DBRA D0,@0 JSR fswap-base(BP) JMP fdrop-base(BP) ; float - double number conversion DC.B 3,'D>F' ; D>F ( d -- n1 n2 n3 n4 n5 ) DC.W froll-theLink dtof: MOVE.L (PS)+,(DP) MOVE.L DP,-(RS) SUBQ.L #6,PS SUBQ.L #4,PS PEA (PS) FL2X RTS DC.B 3,'F>D' ; F>D ( n1 n2 n3 n4 n5 -- d ) DC.W dtof-theLink ftod: PEA (PS) MOVE.L DP,-(RS) FX2L JSR fdrop-base(BP) MOVE.L (DP),-(PS) RTS DC.B 2,'F@',0 ; F@ ( addr -- n5 n4 n3 n2 n1 ) DC.W ftod-theLink fat: MOVE (PS)+,D0 LEA 10(BP,D0.W),A0 MOVE.L -(A0),-(PS) MOVE.L -(A0),-(PS) MOVE -(A0),-(PS) RTS DC.B 2,'F!',0 ; F! ( n5 n4 n3 n2 n1 addr -- ) DC.W fat-theLink fstore: MOVE (PS)+,D0 LEA 0(BP,D0.W),A0 MOVE.L (PS)+,(A0)+ MOVE.L (PS)+,(A0)+ MOVE (PS)+,(A0) RTS DC.B 2,'F,',0 ; F, ( n5 n4 n3 n2 n1 -- ) DC.W fstore-theLink fcomma: MOVE.L (PS)+,(DP)+ MOVE.L (PS)+,(DP)+ MOVE (PS)+,(DP)+ RTS DC.B 9,'FCO' ; FCONSTANT ( comp: f -- ) ( run: -- f ) DC.W fcomma-theLink fcon: JSR create-base(BP) BSR.S fcomma JSR does-base(BP) BRA.S fat DC.B 9,'FVA' ; FVARIABLE ( compile: -- ) ( run: -- addr ) DC.W fcon-theLink fvar: JSR variable-base(BP) ADDQ.L #8,DP RTS DC.B 3,'SCI' ; SCI ( decimal.places -- ) DC.W fvar-theLink sci: CLR -(PS) sci1: MOVE.L (PS)+,form-base(BP) RTS DC.B 3,'FIX' ; FIX ( decimal.places -- ) DC.W sci-theLink fix: MOVE #$FFFF,-(PS) BRA.S sci1 DC.B 2,'F.',0 ; F. ( n5 n4 n3 n2 n1 -- ) DC.W fix-theLink fdot: PEA form-base(BP) PEA (PS) PEA $14(DP) FX2DEC JSR fdrop-base(BP) PEA form-base(BP) PEA $14(DP) MOVE.L A2,-(RS) FDEC2STR dwrd: JSR here-base(BP) JSR count-base(BP) JSR type-base(BP) JMP space-base(BP) DC.B 8,'FCO' ; FCOMPARE ( f1 f2 -- f1 f2 [flag: -1|f1<f2 0|f1=f2 1|f1>f2] ) DC.W fdot-theLink fcomp: MOVE #1,-(PS) PEA 2(PS) PEA 12(PS) FCMPX BGE.S @0 NEG (PS) RTS @0: BNE.S @1 CLR (PS) @1: RTS DC.B 2,'F+',0 ; F+ ( f1 f2 -- f1+f2 ) DC.W fcomp-theLink fplus: PEA (PS) PEA 10(PS) FADDX fd1: JMP fdrop-base(BP) DC.B 2,'F-',0 ; F- ( f1 f2 -- f1-f2 ) DC.W fplus-theLink fminus: PEA (PS) PEA 10(PS) FSUBX BRA.S fd1 DC.B 2,'F*',0 ; F* ( f1 f2 -- f1*f2 ) DC.W fminus-theLink fstar: PEA (PS) PEA 10(PS) FMULX BRA.S fd1 DC.B 2,'F/',0 ; F/ ( f1 f2 -- f1/f2 ) DC.W fstar-theLink fslash: PEA (PS) PEA 10(PS) FDIVX BRA.S fd1 DC.B 4,'FRE' ; FREM ( f1 f2 -- rem[f1/f2] ) DC.W fslash-theLink frem: PEA (PS) PEA 10(PS) FREMX BRA.S fd1 DC.B 2,'F^',0 ; F^ ( f1 f2 -- f1^f2 ) DC.W frem-theLink ftothe: PEA (PS) PEA 10(PS) FXPWRY BRA.S fd1 DC.B 4,'FIN' ; FINT ( f -- int[f] ) DC.W ftothe-theLink finte: PEA (PS) FTINTX RTS DC.B 4,'FAB' ; FABS ( f -- |f| ) DC.W finte -theLink fabs: PEA (PS) FABSX RTS DC.B 5,'FSQ' ; FSQRT ( f -- sqrt[f] ) DC.W fabs-theLink fsqrt: PEA (PS) FSQRTX RTS DC.B 4,'FSI' ; FSIN ( f -- sin[f] ) DC.W fsqrt-theLink fsin: PEA (PS) FSINX RTS DC.B 4,'FCO' ; FCOS ( f -- cos[f] ) DC.W fsin-theLink fcos: PEA (PS) FCOSX RTS DC.B 4,'FTA' ; FTAN ( f -- tan[f] ) DC.W fcos-theLink ftan: PEA (PS) FTANX RTS DC.B 4,'FAT' ; FATN ( f -- atn[f] ) DC.W ftan-theLink fatn: PEA (PS) FATNX RTS DC.B 4,'FEX' ; FEXP ( f1 -- e^f1 ) DC.W fatn-theLink fexp: PEA (PS) FEXPX RTS DC.B 3,'FLN' ; FLN ( f1 -- ln[f1] ) DC.W fexp-theLink fln: PEA (PS) FLNX RTS DC.B 4,'@PE' ; "@pen" ( -- h v ) DC.W fln-theLink AtPen: PEA (DP) _GetPen MOVE.L (DP),-(PS) RTS DC.B 64+4,'!PE' ; "!pen" ( h v -- ) DC.W atpen-theLink SetPen: MOVE.L (PS)+,-(SP) _MoveTo RTS DC.B 64+3,'-TO' ; "-to" ( h v -- ) DC.W setpen-theLink LineTo: MOVE.L (PS)+,-(SP) _LineTo RTS DC.B 64+5,'PMO' ; "pmode" ( mode -- ) DC.W lineto-theLink PMode: MOVE (PS)+,-(SP) _PenMode RTS DC.B 6,'@MO' ; "@mouse" ( -- h v ) DC.W pmode-theLink AtMouse: SUBQ.L #4,PS PEA (PS) _GetMouse RTS DC.B 4,'TAS' ; "task" ( -- ) a no-op word DC.W atmouse-theLink ; use: forget task : task ; Task: RTS ; to cleanup dictionary DictEnd: